Optional Draw-surfaces.f

Requires OpenGL
Requires Sora
Requires GL-Tools
Requires Tools

Only Forth Definitions

create tcoords-X  0 h, 0 h,   1 h, 0 h,   1 h, 1 h,   0 h, 1 h,
create tcoords100%   0 h, 0 h,   1 h, 0 h,   1 h, 1 h,   0 h, 1 h,

0 value tcoords

: texrect  ( w h color -- )
   gl-texture gl-enable
   draw-color
   unbind-vbo
   glTexCoordPointer( 2 GL_SHORT 0 tcoords )
   true 0 0 enable-tnc
   drawarray 1 h[] h@ dup drawarray 3 h[] h!   + dup drawarray 5 h[] h! drawarray 7 h[] h!
   drawarray h@ dup drawarray 6 h[] h!   + dup drawarray 2 h[] h! drawarray 4 h[] h!
   drawarray GL_SHORT 4 GL_QUADS draw-arrays2d ;

: texarea  ( x y w h -- )
   2over 2+ locals| y2 x2 y1 x1 |
   tcoords-X x1 w!+ y1 w!+  x2 w!+ y1 w!+  x2 w!+ y2 w!+  x1 w!+ y2 w!+  drop
   tcoords-X to tcoords ;

: tex100%  ( -- )
   tm-identity   tcoords100% to tcoords ;

\ SLOW!
: draw-surface-part  ( surface x y w h -- )
   2dup  2>r  texarea
   sdl-power/2  dup  dup  sdl-dims  1  1  2swap  texture-granularity
   sdl-texture  dup  bind-texture  2r>  white  texrect   delete-texture  sdl-destroy ;

\ SLOW!
: draw-surface ( surface -- )
   0 0 third sdl-dims draw-surface-part ;
\   sdl-power/2 dup
\   tex100%   dup >r sdl-texture dup bind-texture r> sdl-dims white texrect   delete-texture
\   sdl-destroy ;

\ medium speed
: draw-tile  ( n tileset color -- )
   -rot
   dup ->image @ locals| img ts n |
   ts ->tilew 2v@  img  bind-image-texture
   img image@width ts ->tilew @ /  >r
   n r@ mod  n r> /  1  1  texarea
   ts ->tilew 2v@  rot  texrect
   ;

\ medium speed
: draw-image-part   ( image x y w h -- )
   2dup  2>r   texarea
   bind-image  2r>  white  texrect  ;

\ medium speed
: draw-image  ( image -- )
   0  0  third  ->image-w 2v@  draw-image-part ;

